Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue68/sync/GpFileSync.pas

Pascal/Delphi Source File | 2001-02-28 | 33.4 KB | 1,009 lines

{:File system-based synchronisation primitives.
  (c) 1999-2001 Primoz Gabrijelcic

  @author Primoz Gabrijelcic
  @desc <pre>

  Free for personal and commercial use.
  Tested with Delphi 5. Should work with Delphi 4 but not with older versions.

  Author           : Primoz Gabrijelcic
  Creation date    : 1999-12-02
  Last modification: 2001-02-28
  Version          : 1.06

  </pre>}{

  History:
  1.06: 2001-02-28
    - Added TGpFileSWMR class.

  1.05: 2001-02-26
    - Semantics for TGpCriticalSection.Enter/Leave. It is now possible to
      recursively nest .Enter/.Leave calls. (For example - this sequence is now
      valid:
        cs.Enter;
        cs.Enter;
        cs.Leave; //CS still owned
        cs.Leave; //CS now unowned
      This makes TGpCriticalSection behave more like standard critical section
      in Windows.

  1.04: 2001-01-06
    - All classes renamed from T* to TGp*, exception EFileSync renamed to
      EGpFileSync.

  1.03: 2000-11-16
    - Added 'timeout' parameter to TFileGroup.Join.
    - Changed TFileMutex.Acquire, TFileMutex.Release, TFileGroup.Join,
      TFileGroup.Leave to raise EFileSync exception on various programmer's
      errors.
    - Added TFileGroup.IsMember.

  1.01: 2000-11-12
    - Property TFileSynchroObject.RetryDelay made read/write and public
      (was readonly and protected).
    - TFileMutex.Acquire modified to raise exception if mutex was already
      acquired (was returning 'true'). This also applies to
      TFileCriticalSection.

  1.0: 2000-07-06
    - New class TFileMessage - enhancement of TFileEvent, capable of
      transmitting data.
    - Flowchart: GpFileSync.vsd.
    - TFileMutex.Acquired and TFileMutex.Release were testing handle against 0
      instead of INVALID_HANDLE_VALUE. Fixed.

  0.1: 1999-12-19
    - Fixed External exception on Leave.

  0.0: 1999-12-02
    - First alpha version.
}

unit GpFileSync;

interface

uses
  Windows,
  SysUtils;

const
  //:Default delay between retries in milliseconds.
  CDefRetryDelay = 100;

type
  {:Ancestor of all file synchronisation objects.}
  TGpFileSynchroObject = class
  private
    fsoFileName  : string;
    fsoRetryDelay: integer;
  protected
    constructor Create(syncFile: string; alwaysCheckForWriteAcc: boolean);
    procedure CheckForWriteAccess(folder: string);
    procedure SetRetryDelay(const Value: integer); virtual;
  public
    property  RetryDelay: integer read fsoRetryDelay write SetRetryDelay;
    property  SyncFile: string read fsoFileName;
  end; { TGpFileSynchroObject }

  {:File system-based mutex. Needs write access to lock folder or existing lock
    file. If process crashes while holding mutex, it will be automatically
    released.
  }
  TGpFileMutex = class(TGpFileSynchroObject)
  private
    fmDelete: boolean;
    fmHandle: THandle;
  public
    constructor Create(syncFile: string; deleteOnRelease: boolean = false); reintroduce;
    destructor  Destroy; override;
    function  Acquire(timeout: DWORD): boolean;
    function  Acquired: boolean;
    function  IsFree(timeout: DWORD): boolean;
    procedure Release;
  end; { TGpFileMutex }

  {:File system-based critical section. Just a mutex with simplified access.}
  TGpFileCriticalSection = class(TGpFileMutex)
  private
    nestCount: integer;
  public
    procedure Acquire; reintroduce;
    procedure Enter;
    procedure Leave;
    procedure Release; reintroduce;
  end; { TGpFileCriticalSection }

  {:File system-based group. Needs write access to sync folder or existing
    sync file. Member counting is not implemented. If process crashes, it will
    automatically leave the group. In addition to syncFile, TFileGroup uses
    additional lock file with extension '_lck' and same full name. If, for
    example, sync file is named 'myapp.grp', group lock file will be named
    'myapp.grp_lck'.
  }
  TGpFileGroup = class(TGpFileSynchroObject)
  private
    fgDelete: boolean;
    fgHandle: THandle;
    fgLock  : TGpFileMutex;
  protected
    procedure SetRetryDelay(const Value: integer); override;
  public
    constructor Create(syncFile: string; deleteOnRelease: boolean = false); reintroduce;
    destructor  Destroy; override;
    function  IsEmpty(timeout: DWORD; var emptyGroup: boolean): boolean;
    function  IsMember: boolean;
    function  Join(timeout: DWORD; var isFirstMember: boolean): boolean; overload;
    function  Join(timeout: DWORD): boolean; overload;
    function  Leave(timeout: DWORD; var wasLastMember: boolean): boolean; overload;
    function  Leave(timeout: DWORD): boolean; overload;
  end; { TGpFileGroup }

  {:File system-based Single Writer Multiple Readers (SWMR) synchronisation
    primitive. Uses two mutexes (with extension '_lck1' and '_lck2') and one
    group (using two files - one with extension '_grp' and other with
    '_grp_lck'. Synchronisation file by itself is never used.
    @since   2001-02-28 (1.06)
  }
  TGpFileSWMR = class
  private
    fswmrGroup       : TGpFileGroup;
    fswmrMutex1      : TGpFileMutex;
    fswmrMutex2      : TGpFileMutex;
    fswmrSyncFileBase: string;
    fswmrRetryDelay: integer;
    procedure SetRetryDelay(const Value: integer);
  public
    constructor Create(syncFileBase: string; deleteOnRelease: boolean = false); reintroduce;
    destructor  Destroy; override;
    function  DoneReading(timeout: DWORD): boolean;
    procedure DoneWriting;
    function  IsReading: boolean;
    function  IsWriting: boolean;
    function  WaitToRead(timeout: DWORD): boolean;
    function  WaitToWrite(timeout: DWORD): boolean;
    property  RetryDelay: integer read fswmrRetryDelay write SetRetryDelay;
    property  SyncFile: string read fswmrSyncFileBase;
  end; { TGpFileSWMR }

  {:File system-based event. Needs write access to folder with sync file.
    Persistent by design (synchronisation file is not deleted if signalling
    application crashes).
  }
  TGpFileEvent = class(TGpFileSynchroObject)
  public
    constructor Create(syncFile: string); reintroduce;
    function Reset: boolean;
    function Signal: boolean;
    function WaitFor(timeout: DWORD; reset: boolean): boolean;
  end; { TGpFileEvent }

  {:File system-based messaging. Needs write access to folder with sync file.
    In addition to syncFile, TFileMessage uses lock file with extension '_lck'
    and group files with extensions '_grp' and '_grp_lck', all using syncFile as
    prefix. If, for example, message file is named 'myapp.msg', message lock
    file will be named 'myapp.msg_lck' and message group files will be named
    'myapp.msg_grp' and 'myapp.msg_grp_lck'.
    TFileMessage is non-persistent by design.
    TFileMessage assumes that there is only one sender and one receiver.
    @since 2000-07-06 (1.0)
  }
  TGpFileMessage = class(TGpFileSynchroObject)
  private
    fmLock : TGpFileMutex;
    fmGroup: TGpFileGroup;
  protected
    procedure SetRetryDelay(const Value: integer); override;
  public
    constructor Create(syncFile: string); reintroduce;
    destructor  Destroy; override;
    function  Receive(timeout: DWORD; var msg: pointer; var msgSize: integer): boolean;
    function  Send(timeout: DWORD; msg: pointer; msgSize: integer): boolean;
  end; { TGpFileMessage }

  EGpFileSync = class(Exception);

implementation

const
  FILE_SHARING_ERRORS: set of byte =
    [ERROR_SHARING_VIOLATION, ERROR_LOCK_VIOLATION];

  CAutoDestroyTimeout = 10000; // 5 seconds

resourcestring
  SAlreadyAcquired     = 'Already acquired: %s.';
  SAlreadyJoined       = 'Already joined: %s.';
  SAlreadyReading      = 'Already reading: %s.';
  SAlreadyWriting      = 'Already writing: %s.';
  SCannotAccessFile    = 'Cannot access file %s. Error: "%s"';
  SCannotAcquireMutex  = 'Cannot acquire mutex %s.';
  SCannotCreateFile    = 'Cannot create file %s. Error: "%s"';
  SCannotDeleteFile    = 'Cannot delete file %s. Error: "%s"';
  SCannotJoinGroup     = 'Cannot join group %s.';
  SCannotMoveFilePtr   = 'Cannot move file pointer for file %s to offset %d. Error: "%s"';
  SCannotReadFromFile  = 'Cannot read from file %s. Error: "%s"';
  SCannotWriteToFile   = 'Cannot write to file %s. Error: "%s"';
  SGroupNotEmpty       = 'Group %s is not empty.';
  SIncorrectNumRead    = 'Incorrect number of bytes read from file %s.';
  SIncorrectNumWritten = 'Incorrect number of bytes written to file %s.';
  SNotAcquired         = 'Not acquired: %s.';
  SNotJoined           = 'Not member: %s.';
  SNotReading          = 'Not reading: %s.';
  SNotWriting          = 'Not writing: %s.';
  SNoWriteAccess       = 'Cannot write to folder %s.';

{:Checks if more than 'timeout' time has elapsed since 'start'. Supports
  INFINITE.
}
function Elapsed(start: int64; timeout: DWORD): boolean;
var
  stop: int64;
begin
  if timeout = 0 then
    Result := true
  else if timeout = INFINITE then
    Result := false
  else begin
    stop := GetTickCount;
    if stop < start then
      stop := stop + $100000000;
    Result := ((stop-start) > timeout);
  end;
end; { Elapsed }

{ TGpFileSynchroObject }

{:Checks if process has write access to folder.
  @param   folder Folder being checked.
  @raises  EGpFileSync if write access is not allowed.
}
procedure TGpFileSynchroObject.CheckForWriteAccess(folder: string);
var
  uid: UINT;
  buf: array [0..MAX_PATH] of char;
begin
  uid := GetTempFileName(PChar(folder),'fso',0,buf);
  if uid = 0 then
    raise EGpFileSync.CreateFmt(SNoWriteAccess,[folder])
  else
    DeleteFile(buf);
end; { TGpFileSynchroObject.CheckForWriteAccess }

{:Base constructor. Optionally checks for write access to synchronisation folder.
  @raises  EGpFileSync
}
constructor TGpFileSynchroObject.Create(syncFile: string;
  alwaysCheckForWriteAcc: boolean);
begin
  fsoRetryDelay := CDefRetryDelay; // ms
  fsoFileName := ExpandFileName(syncFile);
  UniqueString(fsoFileName);
  if alwaysCheckForWriteAcc or (not FileExists(fsoFileName)) then
    CheckForWriteAccess(ExtractFilePath(fsoFileName));
end; { TGpFileSynchroObject.Create }

{:Set RetryDelay property.
}
procedure TGpFileSynchroObject.SetRetryDelay(const Value: integer);
begin
  fsoRetryDelay := Value;
end; { TGpFileSynchroObject.SetRetryDelay }

{ TGpFileMutex }

{:Tries to acquire mutex.
  @param   timeout Timeout in milliseconds. 0 and INFINITE are supported.
  @returns true if mutex was acquired.
  @raises  EGpFileSync if sync file cannot be created of if mutex is already
           acquired.
}
function TGpFileMutex.Acquire(timeout: DWORD): boolean;
var
  flag : DWORD;
  err  : DWORD;
  start: int64;
begin
  if Acquired then
    raise EGpFileSync.CreateFmt(SAlreadyAcquired,[SyncFile])
  else begin
    flag := FILE_ATTRIBUTE_NORMAL;
    if fmDelete then
      flag := flag OR FILE_FLAG_DELETE_ON_CLOSE;
    start := GetTickCount;
    repeat
      fmHandle := CreateFile(PChar(SyncFile),GENERIC_READ,0,nil,OPEN_ALWAYS,flag,0);
      if fmHandle = INVALID_HANDLE_VALUE then begin
        err := GetLastError;
        if err in FILE_SHARING_ERRORS then
          Sleep(RetryDelay)
        else
          raise EGpFileSync.CreateFmt(SCannotAccessFile,[SyncFile,SysErrorMessage(err)]);
      end
      else
        err := 0;
    until (err = 0) or Elapsed(start,timeout);
    Result := (err = 0);
  end;
end; { TGpFileMutex.Acquire }

{:Checks if mutex is acquired.
  returns true if mutex is currently acquired.
}
function TGpFileMutex.Acquired: boolean;
begin
  Result := (fmHandle <> INVALID_HANDLE_VALUE);
end; { TGpFileMutex.Acquired }

{:TGpFileMutex constructor.
  @param deleteOnRelease If set, synchronisation file will be deleted on Release.
                         This requires write access to synchronisation folder.
  @raises EGpFileSync if mutex file does not exist and write access to mutex file
          folder is not allowed.
}
constructor TGpFileMutex.Create(syncFile: string; deleteOnRelease: boolean);
begin
  inherited Create(syncFile,false);
  fmDelete := deleteOnRelease;
  fmHandle := INVALID_HANDLE_VALUE;
end; { TGpFileMutex.Create }

{:TGpFileMutex destructor. Releases mutex if acquired.
}
destructor TGpFileMutex.Destroy;
begin
  if Acquired then
    Release;
end; { TGpFileMutex.Destroy }

{:Checks if mutex can be acquired but does not acquire it.
  @returns true if mutex can be acquired.
  @raises  EGpFileSync if sync file cannot be created.
}
function TGpFileMutex.IsFree(timeout: DWORD): boolean;
begin
  if Acquired then
    Result := false
  else begin
    if Acquire(timeout) then begin
      Result := true;
      Release;
    end
    else
      Result := false;
  end;
end; { TGpFileMutex.IsFree }

{:Releases mutex.
  @raises EGpFileSync if mutex is not acquired.
}
procedure TGpFileMutex.Release;
begin
  if Acquired then begin
    CloseHandle(fmHandle);
    fmHandle := INVALID_HANDLE_VALUE;
  end
  else
    raise EGpFileSync.CreateFmt(SNotAcquired,[SyncFile]);
end; { TGpFileMutex.Release }

{ TGpFileCriticalSection }

{:Acquires critical section if not already acquired otherwise just increments
  nesting count.
  @raises EGpFileSync if sync file cannot be created.
}
procedure TGpFileCriticalSection.Acquire;
begin
  if nestCount = 0 then
    inherited Acquire(INFINITE);
  Inc(nestCount);
end; { TGpFileCriticalSection.Acquire }

{:Synonim for Acquire.
}
procedure TGpFileCriticalSection.Enter;
begin
  Acquire;
end; { TGpFileCriticalSection.Enter }

{:Synonym for Release.
}
procedure TGpFileCriticalSection.Leave;
begin
  Release;
end; { TGpFileCriticalSection.Leave }

{:Decrements nesting count and releases critical section when it drops to zero.
  @raises EGpFileSync if critical section is not owned.
}
procedure TGpFileCriticalSection.Release;
begin
  Dec(nestCount);
  if nestCount <= 0 then
    inherited Release;
end; { TGpFileCriticalSection.Release }

{ TGpFileEvent }

{:TGpFileEvent constructor.
  @raises EGpFileSync if program doesn't have rights to create syncFile.
}
constructor TGpFileEvent.Create(syncFile: string);
begin
  inherited Create(syncFile,true);
end; { TGpFileEvent.Create }

{:Resets event.
  @returns false if event is not signaled.
  @raises EGpFileSync if event file couldn't be deleted.
}
function TGpFileEvent.Reset: boolean;
begin
  if not FileExists(SyncFile) then
    Reset := false
  else begin
    if Windows.DeleteFile(PChar(SyncFile)) then
      Result := true
    else
      raise EGpFileSync.CreateFmt(SCannotDeleteFile,[SyncFile,SysErrorMessage(GetLastError)]);
  end;
end; { TGpFileEvent.Reset }

{:Signals event.
  @returns false if event is already signaled.
  @raises EGpFileSync if event file couldn't be created.
}
function TGpFileEvent.Signal: boolean;
var
  h  : THandle;
  err: DWORD;
begin
  h := CreateFile(PChar(SyncFile),GENERIC_READ,0,nil,CREATE_NEW,FILE_ATTRIBUTE_NORMAL,0);
  if h = INVALID_HANDLE_VALUE then begin
    err := GetLastError;
    if err = ERROR_FILE_EXISTS then
      Result := false
    else
      raise EGpFileSync.CreateFmt(SCannotCreateFile,[SyncFile,SysErrorMessage(err)]);
  end
  else begin
    CloseHandle(h);
    Result := true;
  end;
end; { TGpFileEvent.Signal }

{:Waits for event and optionally resets it.
  @param   timeout Timeout, 0 and INFINITE are supported.
  @param   reset   If true, resets event.
  @returns true if event was signaled before timeout.
  @raises  EGpFileSync if sync file cannot be accessed.
}
function TGpFileEvent.WaitFor(timeout: DWORD; reset: boolean): boolean;
var
  flag : DWORD;
  start: int64;
  h    : THandle;
  err  : DWORD;
begin
  flag := FILE_ATTRIBUTE_NORMAL;
  if reset then
    flag := flag OR FILE_FLAG_DELETE_ON_CLOSE;
  start := GetTickCount;
  repeat
    h := CreateFile(PChar(SyncFile),GENERIC_READ,0,nil,OPEN_EXISTING,flag,0);
    if h = INVALID_HANDLE_VALUE then begin
      err := GetLastError;
      if err in (FILE_SHARING_ERRORS+[ERROR_FILE_NOT_FOUND]) then
        Sleep(RetryDelay)
      else
        raise EGpFileSync.CreateFmt(SCannotAccessFile,[SyncFile,SysErrorMessage(err)]);
    end
    else begin
      CloseHandle(h);
      err := 0;
    end;
  until (err = 0) or Elapsed(start,timeout);
  Result := (err = 0);
end; { TGpFileEvent.WaitFor }

{ TGpFileGroup }

{:TGpFileGroup constructor.
  @param  deleteOnRelease If set, synchronisation file will be deleted when last process
          leaves it.
  @raises EGpFileSync if syncFile does not exist and program doesn't have creation rights.
}
constructor TGpFileGroup.Create(syncFile: string; deleteOnRelease: boolean);
begin
  inherited Create(syncFile,false);
  fgHandle := INVALID_HANDLE_VALUE;
  fgDelete := deleteOnRelease;
  fgLock   := TGpFileCriticalSection.Create(syncFile+'_lck',deleteOnRelease);
  fgLock.RetryDelay := RetryDelay;
end; { TGpFileGroup.Create }

{:TGpFileGroup destructor. Leaves group befor destroying it.
}
destructor TGpFileGroup.Destroy;
begin
  if IsMember then
    Leave(CAutoDestroyTimeout);
  fgLock.Free;
  fgLock := nil;
end; { TGpFileGroup.Destroy }

{:Joins the group.
  @param   timeout       Timeout in milliseconds. 0 and INFINITE are supported.
  @param   isFirstMember (out) Set to true if this was first member of the
                         group. Defined only if function returns true.
  @returns false on timeout.
  @raises  EGpFileSync if sync file cannot be created or if already joined.
}
function TGpFileGroup.Join(timeout: DWORD; var isFirstMember: boolean): boolean;
var
  err: DWORD;
begin
  if IsMember then
    raise EGpFileSync.CreateFmt(SAlreadyJoined,[SyncFile])
  else begin
    if not fgLock.Acquire(timeout) then
      Result := false
    else begin
      try
        fgHandle := CreateFile(PChar(SyncFile),GENERIC_READ,0,nil,OPEN_ALWAYS,FILE_ATTRIBUTE_NORMAL,0);
        if fgHandle <> INVALID_HANDLE_VALUE then begin
          isFirstMember := true;
          CloseHandle(fgHandle);
          fgHandle := INVALID_HANDLE_VALUE;
        end
        else begin
          err := GetLastError;
          if err in FILE_SHARING_ERRORS then
            isFirstMember := false
          else
            raise EGpFileSync.CreateFmt(SCannotAccessFile,[SyncFile,SysErrorMessage(err)]);
        end;
        fgHandle := CreateFile(PChar(SyncFile),GENERIC_READ,FILE_SHARE_READ,nil,OPEN_EXISTING,FILE_ATTRIBUTE_NORMAL,0);
        if fgHandle = INVALID_HANDLE_VALUE then
          raise EGpFileSync.CreateFmt(SCannotAccessFile,[SyncFile,SysErrorMessage(GetLastError)]);
      finally fgLock.Release; end;
      Result := true;
    end;
  end;
end; { TGpFileGroup.Join }

{:Leaves the group.
  @param   timeout       Timeout in milliseconds. 0 and INFINITE are supported.
  @param   wasLastMember (out) Set to true if this was last process in the
                         group. Defined only if function returns true.
  @returns false on timeout.
  @raises  EGpFileSync if sync file cannot be deleted and this was last member
           and deleteOnRelease was required. Also raised if not joined.
}
function TGpFileGroup.Leave(timeout: DWORD; var wasLastMember: boolean): boolean;
var
  err: DWORD;
begin
  if not IsMember then
    raise EGpFileSync.CreateFmt(SNotJoined,[SyncFile])
  else begin
    if not fgLock.Acquire(timeout) then
      Result := false
    else begin
      try
        CloseHandle(fgHandle);
        fgHandle := CreateFile(PChar(SyncFile),GENERIC_READ,0,nil,OPEN_EXISTING,FILE_ATTRIBUTE_NORMAL,0);
        if fgHandle <> INVALID_HANDLE_VALUE then begin
          wasLastMember := true;
          CloseHandle(fgHandle);
          fgHandle := INVALID_HANDLE_VALUE;
          if fgDelete then
            if not Windows.DeleteFile(PChar(SyncFile)) then
              raise EGpFileSync.CreateFmt(SCannotDeleteFile,[SyncFile,SysErrorMessage(GetLastError)]);
        end
        else begin
          err := GetLastError;
          if err in FILE_SHARING_ERRORS then
            wasLastMember := false
          else
            raise EGpFileSync.CreateFmt(SCannotAccessFile,[SyncFile,SysErrorMessage(err)]);
        end;
      finally fgLock.Release; end;
      Result := true;
    end;
  end;
end; { TGpFileGroup.Leave }

{:Overloaded Join, does not return status.
  @param   timeout Timeout in milliseconds. 0 and INFINITE are supported.
  @returns false on timeout.
  @raises  EGpFileSync if sync file cannot be created or if already joined.
}
function TGpFileGroup.Join(timeout: DWORD): boolean;
var
  isFirst: boolean;
begin
  Result := Join(timeout,isFirst);
end; { TGpFileGroup.Join }

{:Overloaded Leave, does not return status.
  @param   timeout Timeout in milliseconds. 0 and INFINITE are supported.
  @returns false on timeout.
  @raises  EGpFileSync if sync file cannot be deleted and this was last member
           and deleteOnRelease was required. Also raised if not joined.
}
function TGpFileGroup.Leave(timeout: DWORD): boolean;
var
  wasLast: boolean;
begin
  Result := Leave(timeout,wasLast);
end; { TGpFileGroup.Leave }

{:Checks if file group is empty.
  @param   timeout    Timeout in milliseconds. 0 and INFINITE are supported.
  @param   emptyGroup (out) Set to true if group is empty. Defined only if
                      function returns true.
  @returns false on timeout.
}
function TGpFileGroup.IsEmpty(timeout: DWORD; var emptyGroup: boolean): boolean;
var
  err: DWORD;
begin
  Result := false;
  if not IsMember then begin
    if fgLock.Acquire(timeout) then begin
      try
        fgHandle := CreateFile(PChar(SyncFile),GENERIC_READ,0,nil,OPEN_ALWAYS,FILE_ATTRIBUTE_NORMAL,0);
        if fgHandle <> INVALID_HANDLE_VALUE then begin
          CloseHandle(fgHandle);
          fgHandle := INVALID_HANDLE_VALUE;
          emptyGroup := true;
        end
        else begin
          err := GetLastError;
          if not (err in FILE_SHARING_ERRORS) then
            raise EGpFileSync.CreateFmt(SCannotAccessFile,[SyncFile,SysErrorMessage(err)]);
          emptyGroup := false;
        end;
      finally fgLock.Release; end;
      Result := true;
    end;
  end;
end; { TGpFileGroup.IsEmpty }

{:Checks if instance is already member of group.
  @returns True if instance is already member of group.
  @since   2000-11-16
}
function TGpFileGroup.IsMember: boolean;
begin
  Result := (fgHandle <> INVALID_HANDLE_VALUE);
end; { TGpFileGroup.IsMember }

procedure TGpFileGroup.SetRetryDelay(const Value: integer);
begin
  inherited;
  if assigned(fgLock) then
    fgLock.RetryDelay := Value;
end; { TGpFileGroup.SetRetryDelay }

{ TGpFileMessage }

{:TGpFileMessage constructor.
  @raises EGpFileSync if program doesn't have rights to create syncFile.
}
constructor TGpFileMessage.Create(syncFile: string);
begin
  inherited Create(syncFile,true);
  fmLock := TGpFileMutex.Create(syncFile+'_lck',true);
  fmGroup := TGpFileGroup.Create(syncFile+'_grp',true);
  fmLock.RetryDelay := RetryDelay;
  fmGroup.RetryDelay := RetryDelay;
end; { TGpFileMessage.Create }

{:TGpFileMessage destructor.
}
destructor TGpFileMessage.Destroy;
begin
  FreeAndNil(fmGroup);
  FreeAndNil(fmLock);
  inherited;
end; { TGpFileMessage.Destroy }

{:Receives message.
  @param   timeout   Timeout. INFINITE and 0 are supported.
  @param   msg       Pointer to message data. Will be allocated in Receive with a
                     call to GetMem and should be freed in caller program with a
                     call to FreeMem. Set only when function returns true.
  @param   msgSize   Size of message data. Set only when function returns true.
  @returns true      If message was received in time.
  @raises  EGpFileSync on various errors.
}
function TGpFileMessage.Receive(timeout: DWORD; var msg: pointer; var msgSize: integer): boolean;
var
  err    : DWORD;
  h      : THandle;
  isFirst: boolean;
  read   : DWORD;
  start  : int64;
begin
  Result := false;
  start := GetTickCount;
  repeat
    if not fmLock.Acquire(timeout) then
      raise EGpFileSync.CreateFmt(SCannotAcquireMutex,[SyncFile])
    else begin
      try
        if not fmGroup.Join(timeout,isFirst) then
          raise EGpFileSync.CreateFmt(SCannotJoinGroup,[SyncFile])
        else begin
          try
            if not isFirst then begin
              h := CreateFile(PChar(SyncFile),GENERIC_READ,0,nil,OPEN_EXISTING,FILE_ATTRIBUTE_NORMAL,0);
              if h = INVALID_HANDLE_VALUE then begin
                err := GetLastError;
                if err <> ERROR_FILE_NOT_FOUND then
                  raise EGpFileSync.CreateFmt(SCannotAccessFile,[SyncFile,SysErrorMessage(err)]);
              end
              else begin
                try
                  msgSize := GetFileSize(h,nil);
                  GetMem(msg,msgSize); // will be Free'd by the caller
                  if not ReadFile(h,msg^,msgSize,read,nil) then begin
                    FreeMem(msg);
                    raise EGpFileSync.CreateFmt(SCannotReadFromFile,[SyncFile,SysErrorMessage(GetLastError)])
                  end
                  else if cardinal(msgSize) <> read then begin
                    FreeMem(msg);
                    raise EGpFileSync.CreateFmt(SIncorrectNumRead,[SyncFile]);
                  end;
                finally CloseHandle(h); end;
                // no exception - all OK - continue
                if not Windows.DeleteFile(PChar(SyncFile)) then
                  raise EGpFileSync.CreateFmt(SCannotDeleteFile,[SyncFile,SysErrorMessage(GetLastError)])
                else begin
                  Result := true;
                  Exit;
                end;
              end;
            end;
          finally fmGroup.Leave(timeout); end;
        end;
      finally fmLock.Release; end;
    end;
    if Elapsed(start,timeout) then
      break;
    Sleep(RetryDelay);
  until false;
end; { TGpFileMessage.Receive }

{:Sends a message and waits on recepient to read it. If there is already a
  message waiting to be received, it will be overwritten. If process crashes
  while sending, message will be left on disk but receiving process will know
  that it is invalid.
  @param   timeout   Timeout. INFINITE is supported. 0 is supported but useless.
  @param   msg       Message data.
  @param   msgSize   Message size.
  @returns false     if nobody picks up message in specified time.
  @raises  EGpFileSync on various errors.
}
function TGpFileMessage.Send(timeout: DWORD; msg: pointer; msgSize: integer): boolean;
var
  h      : THandle;
  isFirst: boolean;
  start  : int64;
  written: DWORD;
begin
  Result := false;
  if not fmLock.Acquire(timeout) then
    raise EGpFileSync.CreateFmt(SCannotAcquireMutex,[SyncFile])
  else begin
    try
      if not fmGroup.Join(timeout,isFirst) then
        raise EGpFileSync.CreateFmt(SCannotJoinGroup,[SyncFile])
      else begin
        try
          if not isFirst then
            raise EGpFileSync.CreateFmt(SGroupNotEmpty,[SyncFile])
          else begin
            h := CreateFile(PChar(SyncFile),GENERIC_READ+GENERIC_WRITE,0,nil,CREATE_ALWAYS,FILE_ATTRIBUTE_NORMAL,0);
            if h = INVALID_HANDLE_VALUE then
              raise EGpFileSync.CreateFmt(SCannotCreateFile,[SyncFile,SysErrorMessage(GetLastError)])
            else begin
              try
                if not WriteFile(h,msg^,msgSize,written,nil) then
                  raise EGpFileSync.CreateFmt(SCannotWriteToFile,[SyncFile,SysErrorMessage(GetLastError)])
                else if written <> DWORD(msgSize) then
                  raise EGpFileSync.CreateFmt(SIncorrectNumWritten,[SyncFile])
              finally CloseHandle(h); end;
            end;
            // no exception - all OK - continue
            start := GetTickCount;
            repeat
              if not FileExists(SyncFile) then begin
                Result := true;
                break;
              end
              else if Elapsed(start,timeout) then begin
                if not Windows.DeleteFile(PChar(SyncFile)) then
                  raise EGpFileSync.CreateFmt(SCannotDeleteFile,[SyncFile,SysErrorMessage(GetLastError)])
                else
                  break;
              end
              else begin
                fmLock.Release;
                Sleep(RetryDelay);
                if not fmLock.Acquire(timeout) then
                  raise EGpFileSync.CreateFmt(SCannotAcquireMutex,[SyncFile]);
              end;
            until false;
          end;
        finally fmGroup.Leave(timeout); end;
      end;
    finally
      if fmLock.Acquired then
        fmLock.Release;
    end;
  end;
end; { TGpFileMessage.Send }

procedure TGpFileMessage.SetRetryDelay(const Value: integer);
begin
  inherited;
  if assigned(fmLock) then
    fmLock.RetryDelay := Value;
  if assigned(fmGroup) then
    fmGroup.RetryDelay := Value;
end; { TGpFileMessage.SetRetryDelay }

{ TGpFileSWMR }

{:TGpFileSWMR constructor.
  @param syncFileBase    Synchronisation file base name.
  @param deleteOnRelease If set, synchronisation files will be deleted when not
                         used. This requires write access to synchronisation
                         folder.
  @raises EGpFileSync if synchronisation files do not exist and write access to
          synchronisation folder is not allowed.
}
constructor TGpFileSWMR.Create(syncFileBase: string; deleteOnRelease: boolean);
begin
  inherited Create;
  fswmrSyncFileBase := syncFileBase;
  fswmrMutex1 := TGpFileMutex.Create(syncFileBase+'_lck1',deleteOnRelease);
  fswmrMutex2 := TGpFileMutex.Create(syncFileBase+'_lck2',deleteOnRelease);
  fswmrGroup  := TGpFileGroup.Create(syncFileBase+'_grp',deleteOnRelease);
  fswmrMutex1.RetryDelay := RetryDelay;
  fswmrMutex2.RetryDelay := RetryDelay;
  fswmrGroup.RetryDelay := RetryDelay;
end; { TGpFileSWMR.Create }

destructor TGpFileSWMR.Destroy;
begin
  if IsReading then
    DoneReading(CAutoDestroyTimeout);
  if IsWriting then
    DoneWriting;
  FreeAndNil(fswmrMutex1);
  FreeAndNil(fswmrMutex2);
  FreeAndNil(fswmrGroup);
  inherited;
end; { TGpFileSWMR.Destroy }

{:Releases read lock.
  @param   timeout Timeout. 0 and INFINITE are supported.
  @raises  EGpFileSync if doesn't have read access to SWMR.
}
function TGpFileSWMR.DoneReading(timeout: DWORD): boolean;
begin
  if not IsReading then
    raise EGpFileSync.CreateFmt(SNotReading,[SyncFile])
  else
    Result := fswmrGroup.Leave(timeout);
end; { TGpFileSWMR.DoneReading }

{:Releases write lock.
  @raises  EGpFileSync if doesn't have write access to SWMR.
}
procedure TGpFileSWMR.DoneWriting;
begin
  if not IsWriting then
    raise EGpFileSync.CreateFmt(SNotWriting,[SyncFile])
  else
    fswmrMutex2.Release;
end; { TGpFileSWMR.DoneWriting }

{:Checks if SWMR is acquired for reading.
  @returns True if SWMR is acquired for reading.
}
function TGpFileSWMR.IsReading: boolean;
begin
  Result := fswmrGroup.IsMember;
end; { TGpFileSWMR.IsReading }

{:Checks if SWMR is acquired for writing
  @returns True if SWMR is acquired for writing.
}
function TGpFileSWMR.IsWriting: boolean;
begin
  Result := fswmrMutex2.Acquired;
end; { TGpFileSWMR.IsWriting }

{:Sets RetryDelay for SWMR and subcomponents.
}
procedure TGpFileSWMR.SetRetryDelay(const Value: integer);
begin
  fswmrRetryDelay := Value;
  if assigned(fswmrMutex1) then
    fswmrMutex1.RetryDelay := Value;
  if assigned(fswmrMutex2) then
    fswmrMutex2.RetryDelay := Value;
  if assigned(fswmrGroup) then
    fswmrGroup.RetryDelay := Value;
end; { TGpFileSWMR.SetRetryDelay }

{:Waits until timeout occurs or until process is allowed read access to SWMR.
  @param   timeout Timeout. 0 and INFINITE are supported.
  @returns True if read access was allowed.
  @raises  EGpFileSync if if synchronisation files do not exist and write access to
           synchronisation folder is not allowed.
           EGpFileSync if already has read access.
}
function TGpFileSWMR.WaitToRead(timeout: DWORD): boolean;
var
  start: int64;
begin
  if IsReading then
    raise EGpFileSync.CreateFmt(SAlreadyReading,[SyncFile]);
  start := GetTickCount;
  repeat
    if fswmrMutex1.Acquire(timeout) then begin
      try
        if fswmrMutex2.IsFree(timeout) then
          fswmrGroup.Join(timeout);
      finally fswmrMutex1.Release; end;
    end;
    if fswmrGroup.IsMember or Elapsed(start,timeout) then
      break;
    Sleep(RetryDelay);
  until false;
  Result := IsReading;
end; { TGpFileSWMR.WaitToRead }

{:Waits until timeout occurs or until process is allowed write access to SWMR.
  @param   timeout Timeout. 0 and INFINITE are supported.
  @returns True if write access was allowed.
  @raises  EGpFileSync if if synchronisation files do not exist and write access to
           synchronisation folder is not allowed.
           EGpFileSync if already has write access.
}
function TGpFileSWMR.WaitToWrite(timeout: DWORD): boolean;
var
  isEmptyGroup: boolean;
  start       : int64;
begin
  if IsWriting then
    raise EGpFileSync.CreateFmt(SAlreadyWriting,[SyncFile]);
  start := GetTickCount;
  repeat
    if fswmrMutex1.Acquire(timeout) then begin
      try
        if not fswmrGroup.IsEmpty(timeout,isEmptyGroup) then
          isEmptyGroup := false;
        if isEmptyGroup then // no readers
          if not fswmrMutex2.Acquire(timeout) then
            raise EGpFileSync.CreateFmt(SCannotAcquireMutex,[fswmrMutex2.SyncFile]);
      finally fswmrMutex1.Release; end;
    end;
    if fswmrMutex2.Acquired or Elapsed(start,timeout) then
      break;
    Sleep(RetryDelay);
  until false;
  Result := IsWriting;
end; { TGpFileSWMR.WaitToWrite }

end.